home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xschem28.lzh / SRC / XSFUN1.C < prev    next >
C/C++ Source or Header  |  1991-09-16  |  21KB  |  1,065 lines
  1. /* xsfun1.c - xscheme built-in functions - part 1 */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* gensym variables */
  9. static char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
  10. static int gsnumber = 1;            /* gensym number */
  11.  
  12. /* external variables */
  13. extern LVAL xlenv,xlval,default_object,true;
  14. extern LVAL s_unbound;
  15.  
  16. /* external routines */
  17. extern int eq(),eqv(),equal();
  18.  
  19. /* forward declarations */
  20. #ifdef __STDC__
  21. static LVAL cxr(char *adstr);
  22. static LVAL member(int (*fcn)());
  23. static LVAL assoc(int (*fcn)());
  24. static LVAL nth(int carflag);
  25. static LVAL vref(LVAL vector);
  26. static LVAL vset(LVAL vector);
  27. static LVAL eqtest(int (*fcn)());
  28. #else
  29. static LVAL cxr();
  30. static LVAL member();
  31. static LVAL assoc();
  32. static LVAL nth();
  33. static LVAL eqtest();
  34. static LVAL vref();
  35. static LVAL vset();
  36. #endif
  37.  
  38. /* xcons - construct a new list cell */
  39. LVAL xcons()
  40. {
  41.     LVAL carval,cdrval;
  42.     
  43.     /* get the two arguments */
  44.     carval = xlgetarg();
  45.     cdrval = xlgetarg();
  46.     xllastarg();
  47.  
  48.     /* construct a new cons node */
  49.     return (cons(carval,cdrval));
  50. }
  51.  
  52. /* xcar - built-in function 'car' */
  53. LVAL xcar()
  54. {
  55.     LVAL list;
  56.     list = xlgalist();
  57.     xllastarg();
  58.     return (list ? car(list) : NIL);
  59. }
  60.  
  61. /* xicar - built-in function '%car' */
  62. LVAL xicar()
  63. {
  64.     LVAL arg;
  65.     arg = xlgetarg();
  66.     xllastarg();
  67.     return (car(arg));
  68. }
  69.  
  70. /* xcdr - built-in function 'cdr' */
  71. LVAL xcdr()
  72. {
  73.     LVAL arg;
  74.     arg = xlgalist();
  75.     xllastarg();
  76.     return (arg ? cdr(arg) : NIL);
  77. }
  78.  
  79. /* xicdr - built-in function '%cdr' */
  80. LVAL xicdr()
  81. {
  82.     LVAL arg;
  83.     arg = xlgetarg();
  84.     xllastarg();
  85.     return (cdr(arg));
  86. }
  87.  
  88. /* cxxr functions */
  89. LVAL xcaar() { return (cxr("aa")); }
  90. LVAL xcadr() { return (cxr("da")); }
  91. LVAL xcdar() { return (cxr("ad")); }
  92. LVAL xcddr() { return (cxr("dd")); }
  93.  
  94. /* cxxxr functions */
  95. LVAL xcaaar() { return (cxr("aaa")); }
  96. LVAL xcaadr() { return (cxr("daa")); }
  97. LVAL xcadar() { return (cxr("ada")); }
  98. LVAL xcaddr() { return (cxr("dda")); }
  99. LVAL xcdaar() { return (cxr("aad")); }
  100. LVAL xcdadr() { return (cxr("dad")); }
  101. LVAL xcddar() { return (cxr("add")); }
  102. LVAL xcdddr() { return (cxr("ddd")); }
  103.  
  104. /* cxxxxr functions */
  105. LVAL xcaaaar() { return (cxr("aaaa")); }
  106. LVAL xcaaadr() { return (cxr("daaa")); }
  107. LVAL xcaadar() { return (cxr("adaa")); }
  108. LVAL xcaaddr() { return (cxr("ddaa")); }
  109. LVAL xcadaar() { return (cxr("aada")); }
  110. LVAL xcadadr() { return (cxr("dada")); }
  111. LVAL xcaddar() { return (cxr("adda")); }
  112. LVAL xcadddr() { return (cxr("ddda")); }
  113. LVAL xcdaaar() { return (cxr("aaad")); }
  114. LVAL xcdaadr() { return (cxr("daad")); }
  115. LVAL xcdadar() { return (cxr("adad")); }
  116. LVAL xcdaddr() { return (cxr("ddad")); }
  117. LVAL xcddaar() { return (cxr("aadd")); }
  118. LVAL xcddadr() { return (cxr("dadd")); }
  119. LVAL xcdddar() { return (cxr("addd")); }
  120. LVAL xcddddr() { return (cxr("dddd")); }
  121.  
  122. /* cxr - common car/cdr routine */
  123. static LVAL cxr(adstr)
  124.   char *adstr;
  125. {
  126.     LVAL list;
  127.  
  128.     /* get the list */
  129.     list = xlgalist();
  130.     xllastarg();
  131.  
  132.     /* perform the car/cdr operations */
  133.     while (*adstr && consp(list))
  134.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  135.  
  136.     /* make sure the operation succeeded */
  137.     if (*adstr && list)
  138.     xlbadtype(list);
  139.  
  140.     /* return the result */
  141.     return (list);
  142. }
  143.  
  144. /* xsetcar - built-in function 'set-car!' */
  145. LVAL xsetcar()
  146. {
  147.     LVAL arg,newcar;
  148.  
  149.     /* get the cons and the new car */
  150.     arg = xlgacons();
  151.     newcar = xlgetarg();
  152.     xllastarg();
  153.  
  154.     /* replace the car */
  155.     rplaca(arg,newcar);
  156.     return (arg);
  157. }
  158.  
  159. /* xisetcar - built-in function '%set-car!' */
  160. LVAL xisetcar()
  161. {
  162.     LVAL arg,newcar;
  163.  
  164.     /* get the cons and the new car */
  165.     arg = xlgetarg();
  166.     newcar = xlgetarg();
  167.     xllastarg();
  168.  
  169.     /* replace the car */
  170.     rplaca(arg,newcar);
  171.     return (arg);
  172. }
  173.  
  174. /* xsetcdr - built-in function 'set-cdr!' */
  175. LVAL xsetcdr()
  176. {
  177.     LVAL arg,newcdr;
  178.  
  179.     /* get the cons and the new cdr */
  180.     arg = xlgacons();
  181.     newcdr = xlgetarg();
  182.     xllastarg();
  183.  
  184.     /* replace the cdr */
  185.     rplacd(arg,newcdr);
  186.     return (arg);
  187. }
  188.  
  189. /* xisetcdr - built-in function '%set-cdr!' */
  190. LVAL xisetcdr()
  191. {
  192.     LVAL arg,newcdr;
  193.  
  194.     /* get the cons and the new cdr */
  195.     arg = xlgetarg();
  196.     newcdr = xlgetarg();
  197.     xllastarg();
  198.  
  199.     /* replace the cdr */
  200.     rplacd(arg,newcdr);
  201.     return (arg);
  202. }
  203.  
  204. /* xlist - built-in function 'list' */
  205. LVAL xlist()
  206. {
  207.     LVAL last,next,val;
  208.  
  209.     /* initialize the list */
  210.     val = NIL;
  211.  
  212.     /* add each argument to the list */
  213.     if (moreargs()) {
  214.         val = last = cons(nextarg(),NIL);
  215.         while (moreargs()) {
  216.         next = nextarg();
  217.         push(val);
  218.         next = cons(next,NIL);
  219.         rplacd(last,next);
  220.         last = next;
  221.         val = pop();
  222.     }
  223.     }
  224.  
  225.     /* return the list */
  226.     return (val);
  227. }
  228.  
  229. /* xliststar - built-in function 'list*' */
  230. LVAL xliststar()
  231. {
  232.     LVAL last,next,val;
  233.  
  234.     /* initialize the list */
  235.     val = last = NIL;
  236.  
  237.     /* add each argument to the list */
  238.     if (moreargs()) {
  239.         for (;;) {
  240.         next = nextarg();
  241.         if (moreargs()) {
  242.         push(val);
  243.         next = cons(next,NIL);
  244.         val = pop();
  245.         if (val) rplacd(last,next);
  246.         else val = next;
  247.         last = next;
  248.         }
  249.         else {
  250.         if (val) rplacd(last,next);
  251.         else val = next;
  252.         break;
  253.         }
  254.     }
  255.     }
  256.  
  257.     /* return the list */
  258.     return (val);
  259. }
  260.  
  261. /* xappend - built-in function 'append' */
  262. LVAL xappend()
  263. {
  264.     LVAL next,this,last,val;
  265.  
  266.     /* append each argument */
  267.     for (val = last = NIL; xlargc > 1; )
  268.  
  269.     /* append each element of this list to the result list */
  270.     for (next = xlgalist(); consp(next); next = cdr(next)) {
  271.         push(val);
  272.         this = cons(car(next),NIL);
  273.         val = pop();
  274.         if (last == NIL) val = this;
  275.         else rplacd(last,this);
  276.         last = this;
  277.     }
  278.  
  279.     /* tack on the last argument */
  280.     if (moreargs()) {
  281.     if (last == NIL) val = xlgetarg();
  282.     else rplacd(last,xlgetarg());
  283.     }
  284.  
  285.     /* return the list */
  286.     return (val);
  287. }
  288.  
  289. /* xreverse - built-in function 'reverse' */
  290. LVAL xreverse()
  291. {
  292.     LVAL next,val;
  293.     
  294.     /* get the list to reverse */
  295.     next = xlgalist();
  296.     xllastarg();
  297.  
  298.     /* append each element of this list to the result list */
  299.     for (val = NIL; consp(next); next = cdr(next)) {
  300.     push(val);
  301.     val = cons(car(next),top());
  302.     drop(1);
  303.     }
  304.  
  305.     /* return the list */
  306.     return (val);
  307. }
  308.  
  309. /* xlastpair - built-in function 'last-pair' */
  310. LVAL xlastpair()
  311. {
  312.     LVAL list;
  313.  
  314.     /* get the list */
  315.     list = xlgalist();
  316.     xllastarg();
  317.  
  318.     /* find the last cons */
  319.     if (consp(list))
  320.     while (consp(cdr(list)))
  321.         list = cdr(list);
  322.  
  323.     /* return the last element */
  324.     return (list);
  325. }
  326.  
  327. /* xlength - built-in function 'length' */
  328. LVAL xlength()
  329. {
  330.     FIXTYPE n;
  331.     LVAL arg;
  332.  
  333.     /* get the argument */
  334.     arg = xlgalist();
  335.     xllastarg();
  336.  
  337.     /* find the length */
  338.     for (n = (FIXTYPE)0; consp(arg); ++n)
  339.     arg = cdr(arg);
  340.  
  341.     /* return the length */
  342.     return (cvfixnum(n));
  343. }
  344.  
  345. /* xmember - built-in function 'member' */
  346. LVAL xmember()
  347. {
  348.     return (member(equal));
  349. }
  350.  
  351. /* xmemv - built-in function 'memv' */
  352. LVAL xmemv()
  353. {
  354.     return (member(eqv));
  355. }
  356.  
  357. /* xmemq - built-in function 'memq' */
  358. LVAL xmemq()
  359. {
  360.     return (member(eq));
  361. }
  362.  
  363. /* member - common routine for member/memv/memq */
  364. static LVAL member(fcn)
  365.   int (*fcn)();
  366. {
  367.     LVAL x,list,val;
  368.  
  369.     /* get the expression to look for and the list */
  370.     x = xlgetarg();
  371.     list = xlgalist();
  372.     xllastarg();
  373.  
  374.     /* look for the expression */
  375.     for (val = NIL; consp(list); list = cdr(list))
  376.     if ((*fcn)(x,car(list))) {
  377.         val = list;
  378.         break;
  379.     }
  380.  
  381.     /* return the result */
  382.     return (val);
  383. }
  384.  
  385. /* xassoc - built-in function 'assoc' */
  386. LVAL xassoc()
  387. {
  388.     return (assoc(equal));
  389. }
  390.  
  391. /* xassv - built-in function 'assv' */
  392. LVAL xassv()
  393. {
  394.     return (assoc(eqv));
  395. }
  396.  
  397. /* xassq - built-in function 'assq' */
  398. LVAL xassq()
  399. {
  400.     return (assoc(eq));
  401. }
  402.  
  403. /* assoc - common routine for assoc/assv/assq */
  404. static LVAL assoc(fcn)
  405.   int (*fcn)();
  406. {
  407.     LVAL x,alist,pair,val;
  408.  
  409.     /* get the expression to look for and the association list */
  410.     x = xlgetarg();
  411.     alist = xlgalist();
  412.     xllastarg();
  413.  
  414.     /* look for the expression */
  415.     for (val = NIL; consp(alist); alist